home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / dgamlm.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  1.9 KB  |  57 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (defun dgamlm (xmin xmax)
  12.   (declare (type double-float xmax xmin))
  13.   (prog ((alnbig 0.0) (alnsml 0.0) (xln 0.0) (xold 0.0) (i 0))
  14.     (declare (type f2cl-lib:integer4 i)
  15.              (type double-float xold xln alnsml alnbig))
  16.     (setf alnsml (f2cl-lib:flog (f2cl-lib:d1mach 1)))
  17.     (setf xmin (- alnsml))
  18.     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  19.                   ((> i 10) nil)
  20.       (tagbody
  21.         (setf xold xmin)
  22.         (setf xln (f2cl-lib:flog xmin))
  23.         (setf xmin
  24.                 (+ xmin
  25.                    (/
  26.                     (* (- xmin)
  27.                        (+ (- (* (+ xmin 0.5) xln) xmin 0.2258) alnsml))
  28.                     (+ (* xmin xln) 0.5))))
  29.         (if (< (abs (- xmin xold)) 0.005) (go label20))
  30.        label10))
  31.     (xermsg "SLATEC" "DGAMLM" "UNABLE TO FIND XMIN" 1 2)
  32.    label20
  33.     (setf xmin (- 0.01 xmin))
  34.     (setf alnbig (f2cl-lib:flog (f2cl-lib:d1mach 2)))
  35.     (setf xmax alnbig)
  36.     (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  37.                   ((> i 10) nil)
  38.       (tagbody
  39.         (setf xold xmax)
  40.         (setf xln (f2cl-lib:flog xmax))
  41.         (setf xmax
  42.                 (+ xmax
  43.                    (/
  44.                     (* (- xmax)
  45.                        (- (+ (- (* (- xmax 0.5) xln) xmax) 0.9189) alnbig))
  46.                     (- (* xmax xln) 0.5))))
  47.         (if (< (abs (- xmax xold)) 0.005) (go label40))
  48.        label30))
  49.     (xermsg "SLATEC" "DGAMLM" "UNABLE TO FIND XMAX" 2 2)
  50.    label40
  51.     (setf xmax (- xmax 0.01))
  52.     (setf xmin (max xmin (- 1.0 xmax)))
  53.     (go end_label)
  54.    end_label
  55.     (return (values xmin xmax))))
  56.  
  57.